home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / clue.lha / clue / window-doc.l < prev   
Lisp/Scheme  |  1989-07-12  |  6KB  |  152 lines
  1. ;;; -*- Mode:Lisp; Syntax: Common-lisp; Package:XLIB; Base:10 -*-
  2.  
  3. ;;;
  4. ;;;             TEXAS INSTRUMENTS INCORPORATED
  5. ;;;                  P.O. BOX 2909
  6. ;;;                   AUSTIN, TEXAS 78769
  7. ;;;
  8. ;;; Copyright (C) 1988 Texas Instruments Incorporated.
  9. ;;;
  10. ;;; Permission is granted to any individual or institution to use, copy, modify,
  11. ;;; and distribute this software, provided that this complete copyright and
  12. ;;; permission notice is maintained, intact, in all copies and supporting
  13. ;;; documentation.
  14. ;;;
  15. ;;; Texas Instruments Incorporated provides this software "as is" without
  16. ;;; express or implied warranty.
  17. ;;;
  18.  
  19. ;;; Created 3/03/88 by LGO
  20.  
  21. (in-package 'xlib :use '(lisp))
  22.  
  23. (export '(window-documentation
  24.        change-window-documentation))
  25.  
  26. (defun change-window-documentation (window string &key (mode :replace) format
  27.                     state select font translate)
  28.    ;; STRING will be displayed using FONT when the mouse is over WINDOW
  29.    ;; and (zerop (logand SELECT (logxor STATE current-state)))
  30.    ;; TRANSLATE defaults to #'xlib:translate-default
  31.    ;; FORMAT defaults to STRING when no keywords are specified,
  32.    ;; otherwise it defaults to 8.
  33.    (declare (type window window)
  34.         (type string string)
  35.         (type (member :replace :prepend :append) mode)
  36.         (type (member 8 16 string) format)
  37.         (type modifier-mask state select)
  38.         (type (or null font) font)
  39.         (type (or null translation-function) translate))
  40.   (unless format
  41.     (setq format (if (and (eq mode :replace) (zerop state) (zerop select)
  42.               (null font) (null translate))
  43.              :string 8)))
  44.   (ecase format
  45.     (:string
  46.      (change-property window :wm_documentation (string string) :string 8 :transform #'char->card8))
  47.     (8 (change-window-documentation8 window string mode state select font translate))
  48.     (16 (change-window-documentation16 window string mode state select font translate))))
  49.  
  50. (defun change-window-documentation8 (window string mode state select font translate)
  51.    (declare (type window window)
  52.         (type string string)
  53.         (type (member :replace :prepend :append) mode)
  54.         (type modifier-mask state select)
  55.         (type (or null font) font)
  56.         (type (or null translation-function) translate))
  57.   (let* ((display (window-display window))
  58.      (src-start 0)
  59.      (src-end (length string))
  60.      (length (- src-end src-start))
  61.      (property (intern-atom display :wm_documentation))
  62.      (type property)
  63.      (state (encode-state-mask state))
  64.      (select (encode-state-mask (or select state))))
  65.     (with-buffer-request (display *x-changeproperty* :length length)
  66.       ((data (member :replace :prepend :append)) mode)
  67.       (window window)
  68.       (resource-id property type)
  69.       (card8 8)
  70.       (card32 length)
  71.       (card8 0) ;; Flag to indicate state/select pair
  72.       (card8 (ldb (byte 8 8) state) (ldb (byte 8 0) state))
  73.       (card8 (ldb (byte 8 8) select) (ldb (byte 8 0) select))
  74.       (progn
  75.     (do* ((boffset (index+ buffer-boffset 29))
  76.           (src-chunk 0)
  77.           (dst-chunk 0)
  78.           (offset 0)
  79.           (stop-p nil))
  80.          ((or stop-p (zerop length))
  81.           (card32-put 20 (index- boffset buffer-boffset 24))   ;; Set property length
  82.           (length-put 2 (index-ash (index- (lround boffset) buffer-boffset) -2)) ;; Set request length
  83.           (setf (buffer-boffset display) (lround boffset)))
  84.  
  85.       (declare (type array-index src-chunk dst-chunk offset)
  86.            (type boolean stop-p))
  87.       (setq src-chunk (index-min length *max-string-size*))
  88.       (multiple-value-bind (new-start new-font)
  89.           (funcall (or translate #'translate-default)
  90.                string src-start (index+ src-start src-chunk)
  91.                font buffer-bbuf (index+ boffset 2))
  92.         (setq dst-chunk (index- new-start src-start)
  93.           length (index- length dst-chunk)
  94.           src-start new-start)
  95.         (when (index-plusp dst-chunk)
  96.           (setf (aref buffer-bbuf boffset) dst-chunk)
  97.           (setf (aref buffer-bbuf (index+ boffset 1)) offset)
  98.           (incf boffset (index+ dst-chunk 2)))
  99.         (setq offset 0)
  100.         (cond ((null new-font)
  101.            ;; Don't stop if translate copied whole chunk
  102.            (unless (index= src-chunk dst-chunk)
  103.              (setq stop-p t)))
  104.           ((integerp new-font) (setq offset new-font))
  105.           ((type? new-font 'font)
  106.            (setq font new-font)
  107.            (let ((font-id (font-id font))
  108.              (buffer-boffset boffset))
  109.              (declare (type resource-id font-id)
  110.                   (type array-index buffer-boffset))
  111.              (card8-put 0 #xff)
  112.              (card8-put 1 (ldb (byte 8 24) font-id))
  113.              (card8-put 2 (ldb (byte 8 16) font-id))
  114.              (card8-put 3 (ldb (byte 8 8) font-id))
  115.              (card8-put 4 (ldb (byte 8 0) font-id)))
  116.            (index-incf boffset 5)))
  117.         ))))))
  118.  
  119. ;;;-----------------------------------------------------------------------------
  120.  
  121. (defun window-documentation (window)
  122.   (xlib:get-property window :wm_documentation :type :string
  123.              :result-type 'string :transform #'xlib::card8->char))
  124.  
  125. (defsetf window-documentation (window &optional (format 8)) (doc)
  126.   ;; DOC is a string or list with the following elements:
  127.   ;; :STATE xlib:modifier-mask  - Strings following will use this state with zero select
  128.   ;; :SELECT  xlib:modifier-mask  - Strings following will use this select
  129.   ;; :FONT  (or font stringable)- Use this font for all following strings
  130.   ;; :translate xlib:translation-function  - Use this translation function for all following strings
  131.   ;; string                     - String to use with current state and select
  132.   ;; Example: (:state (:button-1) :select (:button-1) "Foo" :state (:button-2) "Bar")
  133.   ;; This will cause "Foo" to be displayed when button-1 and any other modifier is down in window.
  134.   ;; "Bar" will be displayed when button-2 and ONLY button-2 is down in window.
  135.   `(xlib::set-window-documentation ,window ,doc ,format))
  136.  
  137. (defun set-window-documentation (window doc format)
  138.   (declare (type (or string list) doc)
  139.        (type (member 8 16) format))
  140.   (if (stringp doc)
  141.       (change-property window :wm_documentation (string doc) :string 8 :transform #'char->card8)
  142.     (let ((mode :replace))
  143.     (dolist (args doc)
  144.       (apply 'change-window-documentation window (car args)
  145.          :format format :mode mode (cdr args))
  146.       (setq mode :append))))
  147.   doc)
  148.  
  149. ;; Implement this someday...
  150. (defun change-window-documentation16 (window string mode state select font translate)
  151.   (declare (ignore window string mode state select font translate))
  152.   (error "change-window-documentation16 not implemented yet"))